home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / Boot / telos1.em < prev    next >
Encoding:
Text File  |  1993-07-18  |  28.3 KB  |  797 lines
  1. ;; Eulisp Module
  2. ;; Author: pab
  3. ;; File: telos1.em
  4. ;; Date: Wed Dec 16 20:09:58 1992
  5. ;;
  6. ;; Project:
  7. ;; Description: 
  8. ;;
  9.  
  10. (defmodule telos1
  11.   (
  12.    init  
  13.    defs  macros0  extras0 
  14.    class-names
  15.    gens
  16.    list
  17.    )
  18.   ()
  19.   
  20.   ;; The Mop itself. 
  21.   
  22.   (export allocate initialize make
  23.       ;; core protocol
  24.       compatible-superclasses-p
  25.       compatible-superclass-p
  26.       compute-slot-reader
  27.       compute-slot-descriptions
  28.       compute-inherited-slot-descriptions
  29.       compute-specialized-slot-description
  30.       compute-specialized-slot-description-class
  31.       compute-defined-slot-description
  32.       compute-defined-slot-description-class
  33.       metaclass-default-slot-description-class
  34.       compute-slot-reader
  35.       compute-slot-writer
  36.       ensure-slot-reader
  37.       ensure-slot-writer
  38.       compute-and-ensure-slot-accessors
  39.       compute-primitive-writer-using-slot-description
  40.       compute-primitive-writer-using-class
  41.       compute-primitive-reader-using-slot-description
  42.       compute-primitive-reader-using-class
  43.       compute-precedence-list 
  44.       compute-initargs
  45.       compute-inherited-initargs 
  46.       add-subclass
  47.  
  48.       ;; class/slot access
  49.       class-slot-descriptions
  50.       slot-description-slot-reader
  51.       slot-description-slot-writer
  52.       class-initargs
  53.       class-instance-size
  54.       class-precedence-list
  55.       ;; generic accessors
  56.       find-method
  57.       generic-function-methods
  58.       generic-method-class
  59.  
  60.       find-slot-description
  61.       find-slot-reader
  62.       find-slot-writer
  63.  
  64.       )
  65.   
  66.   (defconstant false nil)
  67.   ;; more accessors
  68.  
  69.   (defun mapcan (f l)
  70.     (fold (lambda (x lst)
  71.         (nconc lst (f x)))
  72.       l
  73.       nil))
  74.   
  75.   (defun nary-string-append x
  76.     (fold (lambda (s x)
  77.         (string-append x
  78.                (cond ((symbolp s)
  79.                   (symbol-unbraced-name s))
  80.                  ((stringp s) s)
  81.                  (t (symbol-unbraced-name (class-name (class-of s)))))))
  82.       x
  83.       ""))
  84.     
  85.   ;; debug vars
  86.   (deflocal xx ())
  87.   (deflocal xxx ())
  88.  
  89.   (defun match-sigs (sig meths)
  90.     (cond ((not (consp meths)) ())
  91.       ((list-equal sig (method-signature (car meths))) (car meths))
  92.       (t (match-sigs sig (cdr meths)))))
  93.  
  94.   (defpredicate local-sd-p <local-slot-description>)
  95.  
  96.   ;; efficiency hacks..
  97.   
  98.   (defconstant readers
  99.     (make-initialized-vector  
  100.      primitive-slot-ref-0  primitive-slot-ref-1     primitive-slot-ref-2   primitive-slot-ref-3
  101.      primitive-slot-ref-4  primitive-slot-ref-5     primitive-slot-ref-6   primitive-slot-ref-7
  102.      primitive-slot-ref-8  primitive-slot-ref-9))
  103.  
  104.   (defconstant writers
  105.     (make-initialized-vector
  106.      primitive-set-slot-ref-0  primitive-set-slot-ref-1     primitive-set-slot-ref-2   primitive-set-slot-ref-3
  107.      primitive-set-slot-ref-4  primitive-set-slot-ref-5     primitive-set-slot-ref-6   primitive-set-slot-ref-7
  108.      primitive-set-slot-ref-8  primitive-set-slot-ref-9))
  109.  
  110.   (defun %compute-reader (n)
  111.     (if (< n 10)
  112.     (vector-ref readers n)
  113.       (lambda (x) (primitive-slot-ref x n))))
  114.  
  115.   (defun %compute-writer (n)
  116.     (if (< n 10)
  117.     (vector-ref writers n)
  118.       (lambda (x y) (primitive-set-slot-ref x n y))))
  119.  
  120.  
  121.  
  122.   (defmethod initialize ((cl <class>) initlist)
  123.     ;; Initialisation is in 3 phases
  124.     (let ((cl (call-next-method)))
  125.       (let ((direct-superclasses (scan-args 'direct-superclasses initlist
  126.                         (default-argument (list <object>))))
  127.         (direct-slot-descriptions (scan-args 'direct-slot-descriptions
  128.                          initlist null-argument))
  129.         (direct-initargs (scan-args 'direct-initargs initlist null-argument)))
  130.     ;; 1. Compatability
  131.     (unless (compatible-superclasses-p cl direct-superclasses)
  132.       (error "Incompatible superclasses." <incompatible-superclasses>
  133.          cl direct-superclasses))
  134.     ((setter class-direct-superclasses) cl direct-superclasses)
  135.     ((setter class-name) cl (scan-args 'name initlist (default-argument '<anonymous>)))
  136.     ((setter class-precedence-list) cl 
  137.      (compute-precedence-list cl direct-superclasses))
  138.     ;; 2a compute cpl
  139.     (let ((initargs 
  140.            ;; 2b initargs
  141.            (compute-initargs cl 
  142.                  direct-initargs
  143.                  (compute-inherited-initargs cl direct-superclasses)))
  144.           ;; 2c slot descriptions, also, we do the ensuring here too...
  145.           (ensured-effective-sds 
  146.            (let ((inherited-slots
  147.               (compute-inherited-slot-descriptions cl direct-slot-descriptions 
  148.                                direct-superclasses)))
  149.          (compute-and-ensure-slot-accessors 
  150.           cl
  151.           (compute-slot-descriptions cl direct-slot-descriptions
  152.                          inherited-slots)
  153.           inherited-slots))))
  154.       ;; 3. Make it all readable....
  155.       ((setter class-initargs) cl initargs)
  156.       ((setter class-slot-descriptions) cl ensured-effective-sds)
  157.       ;; Sort the slot descriptions...
  158.       (labels
  159.        ((sort-slots (lst local nonlocal nlocal)
  160.             (cond ((null lst) 
  161.                    ((setter class-local-slot-descriptions) cl (reverse local))
  162.                    ((setter class-non-local-slot-descriptions) cl nonlocal)
  163.                    ((setter class-instance-size) cl nlocal))
  164.                   ((sane-slot-description-p cl (car lst) ensured-effective-sds)
  165.                    (sort-slots (cdr lst)
  166.                        (cons (make-init-slot nlocal (car lst)) local) 
  167.                        nonlocal (+ nlocal 1)))
  168.                   ((subclassp (class-of (car lst)) <local-slot-description>)
  169.                    (sort-slots (cdr lst) (cons nil local) (cons (car lst) nonlocal) (+ nlocal 1)))
  170.                   (t (sort-slots (cdr lst) local (cons (car lst) nonlocal) nlocal))))
  171.         (make-init-slot (n sd)
  172.                 (cons (slot-description-initarg sd)
  173.                   (slot-description-initfunction sd))))
  174.        (sort-slots (class-slot-descriptions cl) nil nil 0))
  175.       ;; Add the super-classes
  176.       (mapc (lambda (super) (add-subclass super cl) )
  177.         direct-superclasses)
  178.       ((setter class-direct-subclasses) cl nil)
  179.       (set-type cl class-type)
  180.       cl))))
  181.   
  182.   ;; class compatability
  183.   
  184.   (defgeneric compatible-superclasses-p (class list))
  185.   (defgeneric compatible-superclass-p (class list))
  186.  
  187.   (defmethod compatible-superclasses-p ((cl <class>) (direct-superclasses <pair>))
  188.     (and (= (list-length direct-superclasses) 1)
  189.          (compatible-superclass-p cl (car direct-superclasses))))
  190.  
  191.   (defmethod compatible-superclasses-p ((cl <mi-class>) (direct-superclasses <pair>))
  192.     (labels ((loop (superclasses)
  193.            (cond
  194.             ((null superclasses) t)
  195.             ((compatible-superclass-p cl (car superclasses))
  196.              (loop (cdr superclasses)))
  197.             (t false))))
  198.         (loop direct-superclasses)))
  199.  
  200.  (defmethod compatible-superclasses-p ((cl <class>) lst)
  201.    (if (null lst)
  202.        (error "I need some superclasses...~%" <incompatible-superclasses> 'error-value 'none-specified)
  203.      (if (null (cdr lst)) (compatible-superclass-p cl (car lst))
  204.        (error "Too many superclasses for single-inheritance class" <incompatible-superclasses>
  205.           'error-value (cons cl lst)))))
  206.  
  207.  
  208.  (defmethod compatible-superclass-p ((subclass <class>) (superclass <class>)) t)
  209.  
  210.  ;; Precedence lists
  211.  (defgeneric compute-precedence-list (class list))
  212.  
  213.  (defmethod compute-precedence-list ((cl <class>) (direct-superclasses <pair>))
  214.    ;;(format t "comp-cpl: ~a~a~%" cl direct-superclasses)
  215.     (let ((super-cpl (class-precedence-list (car direct-superclasses))))
  216.       (if (memq cl super-cpl)
  217.       (error "Circular hierarchy [How did you manage that?]"
  218.          <illegal-inheritance-hierarchy>
  219.          cl super-cpl)
  220.     (cons cl super-cpl))))
  221.  
  222.  (defun detect (p l)
  223.    (cond ((null l) ())
  224.      ((p (car l)))
  225.      (t (detect p (cdr l)))))
  226.  
  227.  (defun tsort (lsts)
  228.    (if (null lsts) nil
  229.      (let ((firsts (mapcar car lsts))
  230.        (rests (mapcar cdr lsts)))
  231.        (let ((leasts (mapcan (lambda (elt)
  232.                    (if (detect (lambda (l) (memq elt l)) rests)
  233.                    nil
  234.                  (list elt)))
  235.                  (remove-duplicates firsts))))
  236.      (append leasts
  237.          (tsort (mapcan (lambda (l)
  238.                   (if (null l) nil
  239.                     (if (memq (car l) leasts) 
  240.                     (if (cdr l) (list (cdr l)) nil)
  241.                       (list l))))
  242.                 lsts)))))))
  243.  
  244.  (defmethod compute-precedence-list ((cl <mi-class>)  (direct-superclasses <pair>))
  245.    (cons cl (remove-duplicates-from-end (depth-first-preorder direct-superclasses))))
  246.  
  247.  (defun depth-first-preorder (lst)
  248.    (if (null lst) nil
  249.      (cons (car lst)
  250.        (append (depth-first-preorder (cdr (class-precedence-list (car lst))))
  251.            (depth-first-preorder (cdr lst))))))
  252.          
  253.  
  254. ;; computing initargs 
  255.  
  256.  (defgeneric compute-initargs (class direct inherited))
  257.  (defgeneric compute-inherited-initargs (class list))
  258.  
  259.  (defmethod compute-inherited-initargs ((cl <class>) (direct-superclasses <pair>))
  260.     (class-initargs (car direct-superclasses)))
  261.  
  262.   (defmethod compute-inherited-initargs ((cl <mi-class>) (direct-superclasses <pair>))
  263.     (mapappend class-initargs direct-superclasses))
  264.   
  265.   (defmethod compute-initargs ((cl <class>) direct-initargs inherited-initargs)
  266.     (labels ((fold (direct-initargs result)
  267.            (cond
  268.             ((null direct-initargs) result)
  269.             ((memq (car direct-initargs) result) 
  270.              (fold (cdr direct-initargs) result))
  271.             (t (fold (cdr direct-initargs) (cons (car direct-initargs)
  272.                              result))))))
  273.         (fold direct-initargs inherited-initargs)))
  274.  
  275.   (defmethod compute-initargs ((cl <mi-class>) direct-initargs inherited-initargs)
  276.     (remove-duplicates
  277.      (append direct-initargs inherited-initargs)))
  278.    
  279.   ;; computing slot-descriptions
  280.  
  281.   (defgeneric compute-slot-descriptions (class direct-sds inherited-sds))
  282.   (defgeneric compute-inherited-slot-descriptions (class direct-sds superclasses))
  283.   (defgeneric compute-specialized-slot-description (class inherited-sd direct-sd))
  284.   (defgeneric compute-specialized-slot-description-class (class inherited-sd direct-sd))
  285.   (defgeneric compute-defined-slot-description (class direct-sd))
  286.   (defgeneric compute-defined-slot-description-class (class direct-sd))
  287.  
  288. ;;  (defmethod compute-inherited-slot-descriptions ((cl <class>) direct-sds superclasses)
  289. ;;    (mapcar list (class-slot-descriptions (car superclasses))))
  290.   
  291.   ;; Don't really like any of this. Should be able to specify a slot more exactly
  292.   ;; than by name --- name.class or something.
  293.   (defmethod compute-inherited-slot-descriptions ((cl <class>) direct-sds superclasses)
  294.     (reverse (mapcar cdr 
  295.         (fold (lambda (inherited collect)
  296.             (let ((seen (assq (slot-description-name inherited) collect)))
  297.               (if (null seen)
  298.               (cons (list (slot-description-name inherited) inherited) collect)
  299.             (progn ((setter cdr) seen (cons inherited (cdr seen)))
  300.                    collect))))
  301.           (fold append (mapcar class-slot-descriptions superclasses) nil)
  302.           nil))))
  303.             
  304.   (defmethod compute-slot-descriptions ((cl <class>) direct-sds inherited-sds)
  305.     (let ((old-sd-names (mapcan (lambda (sds)
  306.                   (mapcar slot-description-name sds))
  307.                 inherited-sds))
  308.       (new-sd-plist (mapcan (lambda (spec)
  309.                   (list (cons (scan-args 'name spec null-argument) spec)))
  310.                 direct-sds)))
  311.       (append
  312.        (mapcar (lambda (sds)
  313.          (compute-specialized-slot-description
  314.           cl
  315.           sds
  316.           (let ((x (assq (slot-description-name (car sds)) new-sd-plist)))
  317.             (if (null x) nil
  318.               (cdr x)))))
  319.            inherited-sds)
  320.        (mapcan (lambda (named-spec)
  321.          (if (memq (car named-spec) old-sd-names)
  322.              nil
  323.            (list (compute-defined-slot-description cl (cdr named-spec)))))
  324.            new-sd-plist))))
  325.   
  326.   (defmethod compute-specialized-slot-description ((cl <class>) sds spec)
  327.     (let ((sd (car sds))
  328.       (sdclass (compute-specialized-slot-description-class cl sds spec)))
  329.       (if (null spec)
  330.       (if (eq (class-of sd) sdclass) sd
  331.         (let ((new (make sdclass 
  332.                  'name (slot-description-name sd)
  333.                  'reader (slot-description-slot-reader sd)
  334.                  'writer (slot-description-slot-writer sd))))
  335.           (initialize-specialized-slot-description new sds)))
  336.     (let ((new (apply make sdclass
  337.               'reader (slot-description-slot-reader sd)
  338.               'writer (slot-description-slot-writer sd)
  339.               'parent-sds sds 
  340.               spec)))
  341.       (initialize-specialized-slot-description new sds)))))
  342.  
  343.   (defgeneric initialize-specialized-slot-description ((sd <slot-description>) parent-sds))
  344.  
  345.   ;; Tacky really. This part of the protocol _must_ assume mi.
  346.   (defmethod initialize-specialized-slot-description ((sd <slot-description>) parent-sds)
  347.     (if (eq (slot-description-initfunction sd) unbound-slot-value)
  348.     ((setter slot-description-initfunction) sd
  349.      (or (detect (lambda (sd) 
  350.                (if (eq (slot-description-initfunction sd) unbound-slot-value) nil
  351.              (slot-description-initfunction sd)))
  352.              parent-sds)
  353.          unbound-slot-value))
  354.       nil)
  355.     (if (eq (slot-description-initarg sd) unbound-slot-value)
  356.     ((setter slot-description-initarg) sd
  357.      (or (detect (lambda (sd) 
  358.                (if (eq (slot-description-initarg sd) unbound-slot-value) nil
  359.              (slot-description-initarg sd)))
  360.              parent-sds)
  361.          unbound-slot-value))
  362.       nil)
  363.     sd)
  364.  
  365.   (defmethod compute-specialized-slot-description-class ((cl <class>) sds spec)
  366.     (scan-args 'slot-class spec (default-argument (class-of (car sds)))))
  367.  
  368.   (defmethod compute-defined-slot-description ((cl <class>) defn)
  369.     (initialize (allocate (compute-defined-slot-description-class cl defn) defn)
  370.         defn))
  371.  
  372.   (defmethod compute-defined-slot-description-class ((cl <class>) defn)
  373.     (scan-args 'slot-class defn (lambda (a b)
  374.                   (metaclass-default-slot-description-class cl))))
  375.   
  376.   (defgeneric metaclass-default-slot-description-class (class))
  377.   (defmethod metaclass-default-slot-description-class ((cl <class>))
  378.     <local-slot-description>)
  379.  
  380.   (defgeneric compute-and-ensure-slot-accessors (class list list))
  381.  
  382.   (defmethod compute-and-ensure-slot-accessors ((cl <class>) effective-sds inherited-sds)
  383.     (fold (lambda (sd n)
  384.         (cond ((not (subclassp (class-of sd) <local-slot-description>)) n)
  385.           ;;((subclassp (class-of (slot-description-position sd)) number)
  386.           ;; (+ n 1))
  387.           (t ((setter slot-description-position) sd n)
  388.              (+ n 1))))
  389.       effective-sds 0)
  390.     (mapc (lambda (effective-sd)
  391.             (unless (accessors-exist-p effective-sd)
  392.           ;;(format t "Slot: ~a~%" effective-sd)
  393.               ((setter slot-description-slot-reader) 
  394.                effective-sd
  395.                (compute-slot-reader cl effective-sd))
  396.               ((setter slot-description-slot-writer) 
  397.                effective-sd
  398.                (compute-slot-writer cl effective-sd)))
  399.             (ensure-slot-reader cl 
  400.                                 effective-sd
  401.                                 effective-sds 
  402.                                 (slot-description-slot-reader
  403.                                  effective-sd))
  404.             (ensure-slot-writer cl 
  405.                                 effective-sd 
  406.                                 effective-sds
  407.                                 (slot-description-slot-writer
  408.                                  effective-sd)))
  409.           effective-sds)
  410.     effective-sds)
  411.  
  412.   (defmethod compute-and-ensure-slot-accessors ((cl <mi-class>) effective-sds inherited-sds)
  413.     (call-next-method) ;; deals with effective-sds
  414.     (mapc
  415.      (lambda (inherited-sds)
  416.        ;; If we are merging 2 slot-descriptions, life becomes tricky.
  417.        (let ((real-sd (car (member (slot-description-name (car inherited-sds))
  418.                    effective-sds
  419.                    (lambda (name sd) 
  420.                      (eq (slot-description-name sd) 
  421.                      name))))))
  422.      (mapc (lambda (inherited-sd)
  423.          (ensure-slot-reader cl 
  424.                      real-sd
  425.                      effective-sds 
  426.                      (slot-description-slot-reader inherited-sd))
  427.          (ensure-slot-writer cl 
  428.                      real-sd
  429.                      effective-sds
  430.                      (slot-description-slot-writer inherited-sd)))
  431.            inherited-sds)))
  432.      inherited-sds)
  433.     effective-sds)
  434.   
  435.   (defun accessors-exist-p (sd) 
  436.     (and (not (eq (slot-description-slot-reader sd) unbound-slot-value))
  437.      (not (eq (slot-description-slot-writer sd) unbound-slot-value))))
  438.  
  439.   (defgeneric compute-slot-reader (class slot-description))
  440.  
  441.   (defmethod compute-slot-reader ((cl <class>) sd)
  442.     (make <generic-function>
  443.       'lambda-list '(obj) 'method-class <method> 'argtype 1
  444.       'name (make-symbol (nary-string-append (symbol-unbraced-name (class-name cl)) "-" (slot-description-name sd)))
  445.       'domain (list <object>))) ;; could be cl
  446.  
  447.   ;;(make generic-function 'lambda-list '(obj) 'method-class method) ; 'signature (list cl)
  448.   
  449.   (defgeneric compute-slot-writer (class slot-description))
  450.  
  451.   (defmethod compute-slot-writer ((cl <class>) sd )
  452.     ;; 'signature (list cl object)
  453.     (make <generic-function> 'lambda-list '(obj val) 'method-class <method> 'argtype 2
  454.       'name (make-symbol (nary-string-append (symbol-unbraced-name (class-name cl))
  455.                          "-" (slot-description-name sd) "-setter"))
  456.       'domain (list <object> <object>))) ;; could be cl
  457.  
  458.   ;;(make generic-function 'lambda-list '(obj val) 'method-class method)  ; 'signature (list cl object)
  459.  
  460.   (defgeneric ensure-slot-reader (class slot-description <pair> function))
  461.   (defmethod ensure-slot-reader ((cl <class>) (sd <slot-description>) 
  462.                                  (effective-sds <pair>) (gfn <generic-function>))
  463.     ;; in case of single inheritance and local slots only, all slot positions
  464.     ;; remain valid in subclasses. Thus, inherited reader methods remain valid
  465.     ;; as well.
  466.     (when (null (generic-function-methods gfn))
  467.       (let ((reader
  468.              (compute-primitive-reader-using-slot-description sd cl
  469.                                                               effective-sds)))
  470.     ;; XXX: Should use a vector lookup for these..
  471.         (add-method gfn
  472.                     (make <method>
  473.                           'signature (list cl)
  474.                           'function (if (eq (class-of reader) <c-function>)
  475.                     reader
  476.                       (method-lambda (obj)
  477.                              (reader obj)))))
  478.     gfn)))
  479.  
  480.   (defmethod ensure-slot-reader ((cl <class>) (sd <slot-description>)
  481.                  (effective-sds <pair>) (xx <function>))
  482.     xx)
  483.  
  484.   (defmethod ensure-slot-reader ((cl <mi-class>) (sd <slot-description>) 
  485.                                  (effective-sds <pair>) (gfn <generic-function>))
  486.     ;; in case of multiple inheritance slot positions may become invalid in
  487.     ;; subclasses. A more specific method should be added in that case.
  488.     ;; Here is a solution where for each subclass a new method is added.
  489.     (format t "Ensure: ~a ~a ~a~%" cl (slot-description-name sd) gfn)
  490.     (unless (find-method gfn (list cl))
  491.       (let ((reader
  492.              (compute-primitive-reader-using-slot-description sd cl
  493.                                                               effective-sds)))
  494.         (add-method gfn
  495.                     (make <method>
  496.                           'signature (list cl)
  497.                           'function (if (eq (class-of reader) <c-function>) 
  498.                     reader
  499.                       (method-lambda (obj)
  500.                              (reader obj))))))))
  501.   
  502.   (defgeneric ensure-slot-writer (class slot-description <pair> function))
  503.  
  504.   (defmethod ensure-slot-writer ((cl <class>) (sd <slot-description>) 
  505.                                  (effective-sds <pair>) (gfn <generic-function>))
  506.     ;; in case of single inheritance and local slots only, all slot positions
  507.     ;; remain valid in subclasses. Thus, inherited writer methods remain valid
  508.     ;; as well.
  509.     (when (null (generic-function-methods gfn))
  510.       (let ((writer
  511.              (compute-primitive-writer-using-slot-description sd cl
  512.                                                               effective-sds)))
  513.         (add-method gfn
  514.                     (make <method>
  515.                           'signature (list cl <object>)
  516.                           'function (if (eq (class-of writer) <c-function>)
  517.                     writer
  518.                       (method-lambda (obj val)
  519.                              (writer obj val))))))))
  520.  
  521.   (defmethod ensure-slot-writer ((cl <class>) (sd <slot-description>) 
  522.                                  (effective-sds <pair>) (xx <function>))
  523.     xx)
  524.  
  525.   (defmethod ensure-slot-writer ((cl <mi-class>) (sd <slot-description>) 
  526.                                  (effective-sds <pair>) (gfn <generic-function>))
  527.     ;; in case of multiple inheritance slot positions may become invalid in
  528.     ;; subclasses. A more specific method should be added in that case.
  529.     ;; Here is a solution where for each subclass a new method is added.
  530.     (unless (find-method gfn (list cl <object>))
  531.       (let ((writer
  532.              (compute-primitive-writer-using-slot-description sd cl
  533.                                                               effective-sds)))
  534.         (add-method gfn
  535.                     (make <method>
  536.                           'signature (list cl <object>)
  537.                           'function (if (eq (class-of writer) <c-function>)
  538.                     writer
  539.                       (method-lambda (obj val)
  540.                              (writer obj val))))))))
  541.   
  542.   (defgeneric compute-primitive-reader-using-slot-description (slot-description
  543.                                                                class
  544.                                                                <pair>))
  545.   (defmethod compute-primitive-reader-using-slot-description ((sd <slot-description>)
  546.                                   (cl <class>)
  547.                                   (effective-sds <pair>))
  548.     (compute-primitive-reader-using-class cl sd effective-sds))
  549.   
  550.   (defgeneric compute-primitive-writer-using-slot-description (slot-description
  551.                                                                class
  552.                                                                <pair>))
  553.  
  554.   (defmethod compute-primitive-writer-using-slot-description ((sd <slot-description>)
  555.                                   (cl <class>)
  556.                                   (effective-sds <pair>))
  557.     (compute-primitive-writer-using-class cl sd effective-sds))
  558.   
  559.   (defgeneric compute-primitive-reader-using-class (class slot-description <pair>))
  560.   (defmethod compute-primitive-reader-using-class ((cl <class>) (sd <local-slot-description>) (effective-sds <pair>))
  561.     ;; assumption: sd is element of effective-sds
  562.     (let ((local-sds (collect local-sd-p effective-sds)))
  563.       (let ((pos (position sd local-sds eq)))
  564.     (%compute-reader pos))))
  565.         
  566.  
  567.   (defmethod compute-primitive-reader-using-class ((cl <mi-class>) (sd <local-slot-description>) (effective-sds <pair>))
  568.     ;; sd may be an inherited slot description, i.e. not element of effective-sds
  569.     (let ((local-sds (collect local-sd-p effective-sds)))
  570.       (let ((pos (position sd local-sds
  571.                (lambda (sd1 sd2) 
  572.                  (eq (slot-description-name sd1)
  573.                  (slot-description-name sd2))))))
  574.     (%compute-reader pos))))
  575.   
  576.   (defgeneric compute-primitive-writer-using-class (class slot-description <pair>))
  577.   (defmethod compute-primitive-writer-using-class ((cl <class>) 
  578.                            (sd <local-slot-description>)
  579.                            (effective-sds <pair>))
  580.     ;; assumption: sd is element of effective-sds
  581.     (let ((pos (position sd (collect local-sd-p effective-sds) eq)))
  582.       (%compute-writer pos)))
  583.  
  584.   (defmethod compute-primitive-writer-using-class ((cl <mi-class>) (sd <local-slot-description>) (effective-sds <pair>))
  585.     ;; sd may be an inherited slot description, i.e. not element of effective-sds
  586.     (let ((pos (position sd (collect local-sd-p effective-sds)
  587.                          (lambda (sd1 sd2) 
  588.                            (eq (slot-description-name sd1)
  589.                                (slot-description-name sd2))))))
  590.       (%compute-writer pos)))
  591.   
  592.   (defgeneric add-subclass (cl sub))
  593.  
  594.   (defmethod add-subclass ((cl <class>) sub)
  595.     ((setter class-direct-subclasses) cl (cons sub (class-direct-subclasses cl))))
  596.  
  597.   ;; Non-essential methods...
  598.   ;; does an sd have a sensible reader+writer
  599.     (defun sane-slot-description-p (cl slot ensured-effective-sds)
  600.       (and (eq (class-of slot) <local-slot-description>)
  601.        (= (length 
  602.            ((generic-method-lookup-function 
  603.          compute-primitive-writer-using-slot-description)
  604.         (list slot cl ensured-effective-sds)))
  605.           1)
  606.        (= (length 
  607.            ((generic-method-lookup-function 
  608.          compute-primitive-reader-using-slot-description)
  609.         (list slot cl ensured-effective-sds)))
  610.           1)
  611.        (= (length 
  612.            ((generic-method-lookup-function 
  613.          compute-primitive-writer-using-class)
  614.         (list cl slot ensured-effective-sds)))
  615.           1)
  616.        (= (length 
  617.            ((generic-method-lookup-function 
  618.          compute-primitive-reader-using-class)
  619.         (list cl slot ensured-effective-sds)))
  620.           1)))
  621.  
  622.   ;; define defstruct efficiency hacks
  623.  
  624.   (defmethod compute-and-ensure-slot-accessors ((c <structure-class>) effective-sds inherited-sds)
  625.     (labels ((aux (lst n)
  626.           (cond ((null lst) nil)
  627.             ((accessors-exist-p (car lst))
  628.              (aux (cdr lst) (+ n 1)))
  629.             (t ((setter slot-description-slot-reader) (car lst)
  630.                 (make-structure-reader c n))
  631.                ((setter slot-description-slot-writer) (car lst)
  632.                 (make-structure-writer c n))
  633.                ((setter slot-description-position) (car lst) n)
  634.                (aux (cdr lst) (+ n 1))))))
  635.         (aux effective-sds 0)
  636.         effective-sds))
  637.   
  638.   (defmethod compatible-superclass-p ((cl <structure>) (cl <structure>))
  639.     t)
  640.  
  641.   (defmethod compatible-superclass-p ((cl <structure>) cl)
  642.     nil)
  643.  
  644.   (defmethod add-subclass ((x <structure-class>) new)
  645.     (if (subclassp new <structure>)
  646.     (call-next-method)
  647.       (error "Can't subclass structure with a non-structure"
  648.          <illegal-inheritance-hierarchy>
  649.          'error-value new)))
  650.  
  651.   ;; and a new initialize hack for structures
  652.   (add-method initialize (make <method>
  653.                    'signature (list <structure> <object>)
  654.                    'function initialize-local-slots))
  655.  
  656.   ;; Paranoia for primitive-subclasses
  657.   (defmethod  compatible-superclass-p ((new <class>) (cl <primitive-class>))
  658.     nil)
  659.  
  660.   ;; and if someone hacks it
  661.   (defmethod add-subclass ((cl <primitive-class>) sub)
  662.     (error "Can't subclass a primitive-class"
  663.          <illegal-inheritance-hierarchy>
  664.          'error-value sub))
  665.  
  666.   ;; utilities
  667.   (defun position (obj lst fn)
  668.     (labels ((loop (lst pos)
  669.            (cond
  670.             ((null lst) (error "Object not in the list." <element-not-found> 'error-value 
  671.                        (list obj lst fn)))
  672.             ((fn obj (car lst)) pos)
  673.             (t (loop (cdr lst) (+ pos 1))))))
  674.         (loop lst 0)))
  675.  
  676.   (defun remove-duplicates (elements)
  677.     (labels ((fold (elements result)
  678.            (cond
  679.             ((null elements) result)
  680.             ((member (car elements) result eq)
  681.              (fold (cdr elements) result))
  682.             (t (fold (cdr elements) (cons (car elements) result))))))
  683.         (reverse (fold elements '()))))
  684.  
  685.   (defun remove-duplicates-from-end (elements)
  686.     (labels ((fold (elements result)
  687.            (cond
  688.             ((null elements) result)
  689.             ((member (car elements) result eq) (fold (cdr elements) result))
  690.             (t (fold (cdr elements) (cons (car elements) result))))))
  691.         (fold (reverse elements) '())))
  692.   
  693.   (defun mapappend (fn args)
  694.     (labels ((loop (lst result)
  695.            (cond
  696.             ((null lst) result)
  697.             ;;((null (cdr lst)) (append result (fn (car lst))))
  698.             (t (loop (cdr lst) (append result (fn (car lst))))))))
  699.         (loop args '())))
  700.  
  701.   (defun list-equal (lst1 lst2)
  702.     (labels ((loop (l1 l2)
  703.            (cond ((null l1)
  704.               (if (null l2)
  705.                   t
  706.                 nil))
  707.              ((null l2)
  708.               nil)
  709.              ((eq (car l1) (car l2))
  710.               (loop (cdr l1) (cdr l2)))
  711.              (t nil))))
  712.         (loop lst1 lst2)))
  713.  
  714.   (defun collect (fn lst)
  715.     (cond ((null lst) nil)
  716.       ((fn (car lst))
  717.        (cons (car lst)
  718.          (collect fn (cdr lst))))
  719.       (t (collect fn (cdr lst)))))
  720.  
  721.   
  722. ;; Finally, we define the error classes 
  723.  
  724.   (defclass <incompatible-superclasses> (<condition>)
  725.     ()
  726.     ;;metaclass condition-class
  727.     metaclass <class>
  728.     )
  729.  
  730.   (defclass <telos-cannot-happen> (<condition>)
  731.     ()
  732.     ;;metaclass condition-class
  733.     metaclass <class>
  734.     )
  735.  
  736.   (defclass <illegal-inheritance-hierarchy> (<condition>)
  737.     ()
  738.     ;;metaclass condition-class
  739.     metaclass <class>)
  740.  
  741.   (defclass <element-not-found> (<condition>)
  742.     ()
  743.     ;;metaclass condition-class
  744.     metaclass <class>)
  745.   
  746.   (defclass <no-applicable-method> (<condition>)
  747.     ((sig initarg sig))
  748.     ;;metaclass condition-class
  749.     metaclass <class>)
  750.   
  751.   (set-no-applicable-method <no-applicable-method>)
  752.   (export <incompatible-superclasses> <telos-cannot-happen>
  753.       <illegal-inheritance-hierarchy> <element-not-found>
  754.       <no-applicable-method>)
  755.   ;; Real (non-simple) functions...
  756.  
  757.   (defgeneric find-slot-description (class name))
  758.   
  759.   (defmethod find-slot-description ((cl <class>) name)
  760.     (if (eq cl (class-of nil))
  761.     (error "<null> has no slots. please try again"
  762.            'error-value (cons cl name))
  763.       (labels ((aux (slots)
  764.             (cond ((null slots)
  765.                (error "no slot description" <element-not-found> 'error-value (cons cl name)))
  766.               ((eq (slot-description-name (car slots)) name)
  767.                (car slots))
  768.               (t (aux (cdr slots))))))
  769.           (aux (class-slot-descriptions cl)))))
  770.   
  771.   (defun find-slot-reader (class name)
  772.     (slot-description-slot-reader (find-slot-description class name)))
  773.  
  774.   (defun find-slot-writer (class name)
  775.     (slot-description-slot-writer (find-slot-description class name)))
  776.   
  777.   (defclass <not-yet-implemented> (<condition>)())
  778.   (export <not-yet-implemented>)
  779.  
  780.   (defun nyi (msg) (error msg <not-yet-implemented>))
  781.   (export nyi)
  782.  
  783.   (defclass <collection-condition> (<condition>) ())
  784.   (export <collection-condition>)
  785.   
  786.   (defclass <format-error> (<condition>) ())
  787.   (defclass <scan-mismatch> (<condition>) ())
  788.   (export <format-error> <scan-mismatch>)
  789.  
  790.   (defclass <stream-error> (<condition>) ())
  791.   (export <stream-error>)
  792.  
  793.   )
  794.  
  795.  
  796.  
  797.